Pascal Super Library/Pascal Super Library (CW International)(1997).bin/TSR/TSRSRC35/MAPMEM.PAS

Pascal/Delphi Source File | 1993-10-21 | 31KB | 1,034 lines

{**************************************************************************
*   MAPMEM - Reports system memory blocks.                                *
*   Copyright (c) 1986,1993 Kim Kokkonen, TurboPower Software.            *
*   May be freely distributed and used but not sold except by permission. *
***************************************************************************
*   version 1.0 1/2/86                                                    *
*   :                                                                     *
*   long intervening history                                              *
*   :                                                                     *
*   version 3.0 9/24/91                                                   *
*     completely rewritten for DOS 5 compatibility                        *
*     add upper memory reporting                                          *
*     add XMS reporting                                                   *
*     add free memory report                                              *
*     report on EMS handle names                                          *
*     change command line switches                                        *
*     add check for TSR feature                                           *
*     add Quiet option (useful with "check for" option only)              *
*     add summary report                                                  *
*   version 3.1 11/4/91                                                   *
*     fix bug in EMS handle reporting                                     *
*     fix problem in getting name of TSR that shrinks environment (FSP)   *
*     prevent from keeping interrupt 0                                    *
*     fix source naming of WriteChained vs WriteHooked                    *
*     show command line and vectors even if lower part of PSP is          *
*       overwritten (DATAPATH)                                            *
*     wouldn't find (using /C) a program whose name was stored in         *
*       lowercase in the environment (Windows 3.0)                        *
*   version 3.2 11/22/91                                                  *
*     generalize high memory support                                      *
*     handle some DRDOS 6.0 conventions                                   *
*     fix indentation problem in raw extended memory report               *
*   version 3.3 1/8/92                                                    *
*     /C getname wasn't finding TSRs in high memory                       *
*     increase stack space                                                *
*     new features for parsing and getting command line options           *
*   version 3.4 2/14/92                                                   *
*     fix bug in memory reported for device memory blocks                 *
*     add /L option to turn off low memory reporting                      *
*     change /C to find TSRS only in low memory unless /U specified       *
*     add a new test to validate command line strings of mcbs             *
*   version 3.5 10/18/93                                                  *
*     no change                                                           *
***************************************************************************
*   telephone: [phone], CompuServe: 76004,2611.                      *
*   requires Turbo Pascal 6 or 7 to compile.                              *
***************************************************************************}

{$R-,S-,I-,V-,B-,F-,A-,E-,N-,G-,X-}
{$M 4096,2048,655360}
{.$DEFINE MeasureStack}  {Activate to measure stack usage}

program MapMem;

uses
  Dos,
  MemU,
  Xms,
  Ems;

const
  CheckTSR : Boolean = False;          {'C'}
  ShowEmsMem : Boolean = False;        {'E'}
  ShowFree : Boolean = False;          {'F'}
  UseWatch : Boolean = True;           {'H'}
  UseLoMem : Boolean = True;           {'L'}
  Quiet : Boolean = False;             {'Q'}
  ShowSummary : Boolean = False;       {'S'}
  UseHiMem : Boolean = False;          {'U'}
  Verbose : Boolean = False;           {'V'}
  ShowExtMem : Boolean = False;        {'X'}

var
  TotalMem : LongInt;
  TopSeg : Word;
  HiMemSeg : Word;
  WatchPsp : Word;
  ShowDevices : Boolean;
  ShowSegments : Boolean;
  ShowBlocks : Boolean;
  ShowFiles : Boolean;
  ShowVectors : Boolean;
  GotXms : Boolean;
  SizeLen : Byte;
  NameLen : Byte;
  CmdLen : Byte;
  UmbLinkStatus : Boolean;
  SaveExit : Pointer;
  TsrName : string[79];
  {$IFDEF MeasureStack}
  I : Word;
  {$ENDIF}

const
  FreeName  : string[10] = '---free---';
  TotalName : string[10] = '---total--';

const
  VerboseIndent = 5;
  NoShowVecSeg = $FFFE;
  ShowVecSeg   = $FFFF;

  procedure SafeExit; far;
  begin
    ExitProc := SaveExit;
    SwapVectors;
  end;

  function GetName(M : McbPtr; var Devices : Boolean) : String;
    {-Return a name for Mcb M}
  const
    EnvName : array[boolean] of string[4] = ('', 'env');
    DatName : array[boolean] of string[4] = ('', 'data');
  var
    PspSeg : Word;
    IsCmd : Boolean;
  begin
    Devices := False;
    PspSeg := M^.Psp;

    if (PspSeg = 0) or (PspSeg = PrefixSeg) then
      GetName := FreeName
    else if PspSeg = 8 then begin
      GetName := 'sys data';
      if DosV = 5 then
        if (M^.Name[1] = 'S') and (M^.Name[2] = 'D') then begin
          GetName := 'cfg info';
          Devices := True;
        end;
    end else if (PspSeg < 8) or (PspSeg >= $FFF0) then
      GetName := 'unknown'
    else if PspSeg = OS(M).S+1 then begin
      {program block}
      IsCmd := (PspSeg = MemW[PspSeg:$16]);
      if (not IsCmd) and (DosV > 2) and HasEnvironment(HiMemSeg, M) then
        GetName := NameFromEnv(M)
      else if DosV >= 4 then
        GetName := NameFromMcb(M)
      else if IsCmd then
        GetName := 'command'
      else if DosVT >= $031E then
        GetName := NameFromMcb(M)
      else
        GetName := 'n/a';
    end else if MemW[PspSeg:$2C] = OS(M).S+1 then
      GetName := EnvName[Verbose]+'('+GetName(Ptr(PspSeg-1, 0), Devices)+')'
    else
      GetName := DatName[Verbose]+'('+GetName(Ptr(PspSeg-1, 0), Devices)+')';
  end;

  function ValidPsp(PspSeg : Word) : Boolean;
    {-Return True if PspSeg is a valid Psp}
  begin
    if ((PspSeg >= 0) and (PspSeg <= 8)) or
       (PspSeg = PrefixSeg) or
       (PspSeg >= $FFF0) then
      ValidPsp := False
    else
      ValidPsp := True;
  end;

  function GetFiles(M : McbPtr) : Word;
    {-Return number of open files for given Mcb's Psp}
  type
    HandleTable = array[0..65520] of Byte;
  var
    PspSeg : Word;
    O : Word;
    Files : Word;
    FileMax : Word;
    TablePtr : ^HandleTable;
  begin
    PspSeg := M^.Psp;
    if (PspSeg <> OS(M).S+1) or not ValidPsp(PspSeg) or
       (MemW[PspSeg:$50] <> $21CD) then begin
      GetFiles := 0;
      Exit;
    end;
    {Deal with expanded handle tables in DOS 3.0 and later}
    if DosV >= 3 then begin
      FileMax := MemW[M^.Psp:$32];
      TablePtr := Pointer(MemL[M^.Psp:$34]);
    end else begin
      FileMax := 20;
      TablePtr := Ptr(M^.Psp, $18);
    end;

    Files := 0;
    for O := 0 to FileMax-1 do
      case TablePtr^[O] of
        0, 1, 2, $FF : {standard handle or not open} ;
      else
        Inc(Files);
      end;
    GetFiles := Files;
  end;

  function GetCmdLine(M : McbPtr) : String;
    {-Return command line for program}
  var
    PspSeg : Word;
    Len : Byte;
    S : String[127];
  begin
    PspSeg := M^.Psp;
    if (PspSeg <> OS(M).S+1) or not ValidPsp(PspSeg) then begin
      GetCmdLine := '';
      Exit;
    end;
    Move(Mem[PspSeg:$80], S, 127);
    if S <> '' then begin
      Len := Length(S);
      if (Len > 127) or (S[Len+1] <> ^M) then
        S := ''
      else
        StripNonAscii(S);
      if S = '' then
        S := 'n/a';
    end;
    while (Length(S) > 0) and (S[1] = ' ') do
      Delete(S, 1, 1);
    GetCmdLine := S;
  end;

  procedure WriteHooked(LowSeg, HighSeg : Word; StartCol, WrapCol : Byte);
    {-Write vectors that point into specified region of memory}
  var
    Vectors : array[0..255] of Pointer absolute 0:0;
    Vec : Pointer;
    LoL : LongInt;
    HiL : LongInt;
    VeL : LongInt;
    V : Byte;
    Col : Byte;
  begin
    LoL := LongInt(LowSeg) shl 4;
    HiL := LongInt(HighSeg) shl 4;
    Col := StartCol;
    for V := 0 to 255 do begin
      Vec := Vectors[V];
      VeL := (LongInt(OS(Vec).S) shl 4)+OS(Vec).O;
      if (VeL >= LoL) and (VeL < HiL) then begin
        if Col+3 > WrapCol then begin
          {wrap to next line}
          Write(^M^J, '':StartCol-1);
          Col := StartCol;
        end;
        Write(HexB(V), ' ');
        inc(Col, 3);
      end;
    end;
  end;

  procedure WriteChained(PspSeg : Word; StartCol, WrapCol : Byte);
    {-Write vectors that WATCH found taken over by a block}
  var
    P : ^ChangeBlock;
    I, MaxChg, Col : Word;
    Found : Boolean;
  begin
    {initialize}
    MaxChg := MemW[WatchPsp:NextChange];
    Col := StartCol;
    Found := False;
    I := 0;

    while I < MaxChg do begin
      P := Ptr(WatchPsp, ChangeVectors+I);
      with P^ do
        case ID of
          $00 :           {ChangeBlock describes an active vector takeover}
            if Found then begin
              if Col+3 > WrapCol then begin
                {wrap to next line}
                Write(^M^J, '':StartCol-1);
                Col := StartCol;
              end;
              Write(HexB(Lo(VecNum)), ' ');
              inc(Col, 3);
            end;
          $01 :           {ChangeBlock specifies a disabled takeover}
            if Found then begin
              Write('disabled');
              {Don't write this more than once}
              Exit;
            end;
          $FF :           {ChangeBlock starts a new PSP}
            Found := (PspSeg = PspAdd);
        end;
      inc(I, SizeOf(ChangeBlock));
    end;
  end;

  procedure WriteVectors(LowSeg, HighSeg : Word; StartCol, WrapCol : Byte);
    {-Write interrupt vectors either hooked or chained}
  begin
    if UseWatch then
      WriteChained(LowSeg, StartCol, WrapCol)
    else
      WriteHooked(LowSeg, HighSeg, StartCol, WrapCol);
  end;

  procedure WriteMcb(McbSeg, PspSeg, Paras, Blocks, Files : Word;
                     Name : String; CmdLine : String);
    {-Write information about one Mcb or group of mcbs}
  var
    Col : Byte;
  begin
    Col := 1;

    if ShowSegments then begin
      case McbSeg of
        NoShowVecSeg, ShowVecSeg : ;
      else
        Write(HexW(McbSeg), ' ');
        inc(Col, 5);
      end;

      if (PspSeg = 0) or (PspSeg = 8) then
        Write('    ')
      else
        Write(HexW(PspSeg));
      inc(Col, 4);
    end else
      Write('  ');

    if ShowBlocks then begin
      Write(' ', Blocks:2);
      inc(Col, 3);
    end;

    if ShowFiles then begin
      if Files = 0 then
        Write('   ')
      else
        Write(' ', Files:2);
      inc(Col, 3);
    end;

    Write(' ', CommaIze(LongInt(Paras) shl 4, SizeLen),
          ' ', Extend(Name, NameLen),
          ' ', SmartExtend(CmdLine, CmdLen));
    inc(Col, 3+SizeLen+NameLen+CmdLen);

    if ShowVectors then
      if (PspSeg = McbSeg+1) or (McbSeg = ShowVecSeg) then
        if ValidPsp(PspSeg) then begin
          Write(' ');
          WriteVectors(PspSeg, PspSeg+Paras, Col+1, 79);
        end;

    WriteLn;

    {keep track of total reported memory}
    Inc(TotalMem, Paras);
    Inc(TotalMem, Blocks);        {for the mcbs themselves}
  end;

  procedure WriteDevices(DevSeg, NextSeg : Word);
    {-Write the DOS 5 device list}
  var
    D : McbPtr;
    Name : String[79];
  begin
    D := Ptr(DevSeg, 0);
    while OS(D).S < NextSeg do begin
      case D^.Id of
        'B' : Name := 'buffers';
        'C' : Name := 'ems buffers';
        'D' : Name := 'device='+Asc2Str(D^.Name);
        'E' : Name := 'device ext';
        'F' : Name := 'files';
        'I' : Name := 'ifs='+Asc2Str(D^.Name);
        'L' : Name := 'lastdrive';
        'S' : Name := 'stacks';
        'X' : Name := 'fcbs';
      else
        Name := '';
      end;
      if Name <> '' then
        WriteLn('':20, CommaIze(LongInt(D^.Len+1) shl 4, 6), ' ', Name);
      D := Ptr(OS(D).S+D^.Len+1, 0);
    end;
  end;

  procedure WriteTotalMem;
    {-Write total reported memory with leading space PreSpace}
  var
    PreSpace : Word;
  begin
    if TotalMem <> 0 then begin
      PreSpace := 7;
      if Verbose then
        inc(PreSpace, VerboseIndent);
      WriteLn('':PreSpace, CommaIze(LongInt(TotalMem) shl 4, 8), ' ', TotalName);
      TotalMem := 0;
    end;
  end;

  procedure FindTSR;
    {-Find TSRName, report if appropriate, and halt}

    procedure FindOne(Start : McbPtr);
    var
      M : McbPtr;
      PspSeg : Word;
      Done : Boolean;
      IsCmd : Boolean;
      Name : String[79];
    begin
      M := Start;
      repeat
        PspSeg := M^.Psp;
        if OS(M).S+1 = PspSeg then begin
          IsCmd := (PspSeg = MemW[PspSeg:$16]);
          if (not IsCmd) and (DosV > 2) and HasEnvironment(HiMemSeg, M) then
            Name := NameFromEnv(M)
          else if DosV >= 4 then
            Name := NameFromMcb(M)
          else if (not IsCmd) and (DosVT >= $031E) then
            Name := NameFromMcb(M)
          else
            Name := '';
          if StUpcase(Name) = TsrName then begin
            if not Quiet then
              WriteLn('Found ', TsrName, ' at ', HexW(PspSeg));
            Halt(0);
          end;
        end;
        Done := (M^.Id = 'Z');
        M := Ptr(OS(M).S+M^.Len+1, 0);
      until Done;
    end;

  begin
    if UseLoMem then
      FindOne(Mcb1);
    if UseHiMem then
      FindOne(Ptr(HiMemSeg, 0));
    {Not found if we get here}
    if not Quiet then
      WriteLn('Did not find ', TsrName);
    Halt(2);
  end;

  procedure ShowChain(M : McbPtr);
    {-Show chain of blocks starting at M}
  var
    Done : Boolean;
  begin
    repeat
      WriteMcb(OS(M).S, M^.Psp, M^.Len, 1,
               GetFiles(M), GetName(M, ShowDevices), GetCmdLine(M));
      if ShowDevices then
        WriteDevices(OS(M).S+1, OS(M).S+M^.Len+1);
      Done := (M^.Id = 'Z');
      M := Ptr(OS(M).S+M^.Len+1, 0);
    until Done;
    WriteTotalMem;
  end;

  procedure WriteVerbose;
    {-Report on each Mcb individually}
  var
    M : McbPtr;
  begin
    Write('Mcb  Psp  Hdl   Size Name           Command Line        ');
    if UseWatch then
      Write('Chained')
    else
      Write('Hooked');
    WriteLn(' Vectors');
    WriteLn('---- ---- --- ------ -------------- ------------------- -----------------------');

    if UseLoMem then begin
      {fake Mcb's used by dos itself}
      WriteMcb($0000, $0000, $0040, 0, 0, 'vectors', '');
      WriteMcb($0040, $0000, $0010, 0, 0, 'BIOS data', '');
      WriteMcb($0050, $0000, $0020, 0, 0, 'DOS data', '');
      WriteMcb($0070, $0000, OS(DosList).S-$70, 0, 0, 'sys data', '');
      WriteMcb(OS(DosList).S, $0000, OS(Mcb1).S-OS(DosList).S, 0, 0, 'sys code', '');
      M := Mcb1;
      ShowChain(Mcb1);
    end;

    if UseHiMem then begin
      if UseLoMem then
        WriteLn(^M^J'High Memory');
      ShowChain(Ptr(HiMemSeg, 0));
    end;
  end;

  procedure SummarizePsp(TPsp, LoMcb, HiMcb : Word);
    {-Write info about all Mcbs in range LoMcb..HiMcb with the specified Psp}
  var
    TM : McbPtr;
    M : McbPtr;
    Size : Word;
    Blocks : Word;
    FakeSeg : Word;
    MPsp : Word;
    Done : Boolean;
    HaveCodeBlock : Boolean;
  begin
    Size := 0;
    Blocks := 0;
    M := Ptr(LoMcb, 0);
    TM := nil;
    HaveCodeBlock := False;
    repeat
      MPsp := M^.Psp;
      if MPsp = 0 then
        MPsp := OS(M).S;
      if MPsp = TPsp then begin
        if (OS(M).S >= LoMcb) and (OS(M).S < HiMcb) then begin
          Inc(Size, M^.Len);
          Inc(Blocks);
          if OS(M).S+1 = TPsp then
            HaveCodeBlock := True;
        end;
        if TM = nil then
          TM := M
        else if M^.Psp = OS(M).S+1 then
          TM := M;
      end;
      Done := (M^.Id = 'Z');
      M := Ptr(OS(M).S+M^.Len+1, 0);
    until Done;

    if Blocks > 0 then begin
      if HaveCodeBlock then
        FakeSeg := ShowVecSeg
      else
        FakeSeg := NoShowVecSeg;
      WriteMcb(FakeSeg, TM^.Psp, Size, Blocks, 0,
               GetName(TM, ShowDevices), GetCmdLine(TM));
    end;
  end;

  procedure SummarizeRange(LoMcb, HiMcb : Word);
    {-Summarize Psps in the range LoMcb..HiMcb,
      for Psp > 8, Psp < $FFF0, and Psp <> PrefixSeg}
  var
    M : McbPtr;
    MinPsp : Word;
    TPsp : Word;
    PrvPsp : Word;
    Done : Boolean;
  begin
    PrvPsp := 8;
    repeat
      {find the smallest Psp not yet summarized}
      MinPsp := $FFFF;
      M := Ptr(LoMcb, 0);
      repeat
        TPsp := M^.Psp;
        if TPsp = 0 then
          TPsp := OS(M).S;
        if TPsp < MinPsp then
          if (TPsp > PrvPsp) and (TPsp < $FFF0) and (TPsp <> PrefixSeg) then
            MinPsp := TPsp;
        Done := (M^.Id = 'Z');
        M := Ptr(OS(M).S+M^.Len+1, 0);
      until Done;

      if MinPsp <> $FFFF then begin
        {add up info about this Psp}
        SummarizePsp(MinPsp, LoMcb, HiMcb);
        {"mark out" this Psp}
        PrvPsp := MinPsp;
      end;
    until MinPsp = $FFFF;
  end;

  procedure SummarizeDos(LoMcb, HiMcb : Word);
    {-Sum up memory attributed to DOS}
  var
    M : McbPtr;
    Size : Word;
    Blocks : Word;
    FakeSeg : Word;
    Done : Boolean;
  begin
    M := Ptr(LoMcb, 0);
    Size := 0;
    Blocks := 0;
    repeat
      if M^.Psp = 8 then
        if (OS(M).S >= LoMcb) and (OS(M).S < HiMcb) then begin
          Inc(Size, M^.Len);
          Inc(Blocks);
        end;
      Done := (M^.Id = 'Z');
      M := Ptr(OS(M).S+M^.Len+1, 0);
    until Done;
    if Blocks > 0 then begin
      if HiMcb > TopSeg then
        FakeSeg := NoShowVecSeg
      else
        FakeSeg := ShowVecSeg;
      WriteMcb(FakeSeg, $00, OS(Mcb1).S+Size, Blocks, 0, 'DOS', '');
    end;
  end;

  procedure SummarizeFree(LoMcb, HiMcb : Word);
    {-Write the free memory blocks in specified range of Mcbs}
  var
    M : McbPtr;
    Done : Boolean;
  begin
    M := Ptr(LoMcb, 0); {!!}
    {M := Mcb1;}        {!!}
    repeat
      if (M^.Psp = 0) and (M^.Len > 0) and
         (OS(M).S >= LoMcb) and (OS(M).S < HiMcb) then
        WriteMcb(NoShowVecSeg, $0000, M^.Len, 1, 0, FreeName, '');
      Done := (M^.Id = 'Z');
      M := Ptr(OS(M).S+M^.Len+1, 0);
    until Done;
  end;

  procedure WriteCondensed;
    {-Report on Mcb's by Psp}
  begin
    Write('Psp  Cnt   Size Name       Command Line        ');
    if UseWatch then
      Write('Chained')
    else
      Write('Hooked');
    WriteLn(' Vectors');
    WriteLn('---- --- ------ ---------- ------------------- --------------------------------');

    if UseLoMem then begin
      SummarizeDos(OS(Mcb1).S, TopSeg-1);  {DOS memory usage}
      SummarizeRange(OS(Mcb1).S, TopSeg-1);{programs loaded in low memory}
      SummarizePsp(PrefixSeg, OS(Mcb1).S, $FFFF);   {current program free space}
      WriteTotalMem;                       {sum of memory so far}
    end;

    if UseHiMem then begin
      if UseLoMem then
        WriteLn(^M^J'High Memory');
      SummarizeDos(HiMemSeg, $FFFF);
      SummarizeRange(HiMemSeg, $FFFF);
      WriteTotalMem;
    end;
  end;

  procedure WriteFree;
    {-Show just the free blocks in conventional memory}
  begin
    if UseLoMem then begin
      WriteLn('Normal Memory');
      SummarizeFree(OS(Mcb1).S, TopSeg-1);         {free blocks in low memory}
      SummarizePsp(PrefixSeg, OS(Mcb1).S, $FFFF);  {current program free space}
    end;
    if UseHiMem then begin
      if UseLoMem then
        WriteLn(^M^J'High Memory');
      SummarizeFree(HiMemSeg, $FFFF);
    end;
  end;

  procedure WriteSummary;
    {-Write "summary" report for conventional memory}
  begin
    WriteLn('      Size Name       Command Line');
    WriteLn('---------- ---------- --------------------------------------------------------');

    if UseLoMem then begin
      SummarizeDos(OS(Mcb1).S, TopSeg-1);            {DOS memory usage}
      SummarizeRange(OS(Mcb1).S, TopSeg-1);          {programs loaded in low memory}
      SummarizePsp(PrefixSeg, OS(Mcb1).S, $FFFF);    {current program free space}
    end;
    if UseHiMem then begin
      if UseLoMem then
        WriteLn(^M^J'High Memory');
      SummarizeDos(HiMemSeg, $FFFF);
      SummarizeRange(HiMemSeg, $FFFF);
    end;
  end;

  procedure ShowConventionalMem;
    {-Report on conventional memory, low and high}
  begin
    {Default values for display}
    ShowSegments := True;
    ShowBlocks := False;
    ShowFiles := False;
    ShowVectors := True;
    SizeLen := 7;
    NameLen := 10;
    CmdLen := 19;

    if ShowFree then begin
      ShowSegments := False;
      ShowVectors := False;
      WriteFree;
    end else if ShowSummary then begin
      ShowSegments := False;
      ShowVectors := False;
      CmdLen := 56;
      WriteSummary;
    end else if Verbose then begin
      ShowFiles := True;
      NameLen := 14;
      WriteVerbose;
    end else begin
      ShowBlocks := True;
      WriteCondensed;
    end;
  end;

  procedure ShowTheEmsMem;
  var
    Handles : Word;
    H : Word;
    P : Word;
    Pages : LongInt;
    EmsV : Byte;
    PreSpace : Byte;
    Name : string[9];
    PageMap : PageArray;
  begin
    if not EmsPresent then
      Exit;
    WriteLn;
    WriteLn('EMS Memory');
    if not(ShowFree or ShowSummary) then begin
      EmsV := EmsVersion;
      Handles := EmsHandles(PageMap);
      if Handles > 0 then
        for H := 1 to Handles do begin {!!}
          P := PageMap[H].NumPages;
          if P <> 0 then begin
            Write(HexW(H), ' ');
            if Verbose then
              Write('':VerboseIndent);
            Write(CommaIze(LongInt(P) shl 14, 10));
            if EmsV >= $40 then begin
              GetHandleName(PageMap[H].Handle, Name);
              if Name = '' then
                Name := 'n/a';
            end else
              Name := 'n/a';
            WriteLn(' ', Name);
          end;
        end;
    end;
    Pages := EmsPagesAvailable;
    if ShowFree or ShowSummary then
      PreSpace := 0
    else
      PreSpace := 5;
    if Verbose then
      inc(PreSpace, VerboseIndent);
    WriteLn('':PreSpace, CommaIze(LongInt(OS(Pages).O) shl 14, 10), ' ', FreeName);
    if ShowSummary or (not ShowFree) then
      WriteLn('':PreSpace, CommaIze(LongInt(OS(Pages).S) shl 14, 10), ' ', TotalName);
  end;

  procedure ShowTheXmsMem;
    {-Show what we can about XMS}
  label
    ExitPoint;
  var
    FMem : Word;
    FMax : Word;
    XHandles : Word;
    H : Word;
    HMem : Word;
    Total : Word;
    XmsPages : XmsHandlesPtr;
    Status : Byte;
    PreSpace : Byte;
  begin
    if not XmsInstalled then
      Exit;
    Status := QueryFreeExtMem(FMem, FMax);
    if Status = $A0 then begin
      FMem := 0;
      FMax := 0;
    end else if Status <> 0 then
      Exit;

    {Total will count total XMS memory}
    Total := 0;

    WriteLn(^M^J'XMS Memory');
    GotXms := not Verbose;

    if ShowFree then
      goto ExitPoint;

    {Get an array containing handles}
    XHandles := GetXmsHandles(XmsPages);

    {Report all the handles}
    for H := 1 to XHandles do begin
      HMem := XmsPages^[H].NumPages;
      if not ShowSummary then begin
        Write(HexW(H), ' ');
        if Verbose then
          Write('':VerboseIndent);
        WriteLn(CommaIze(LongInt(HMem) shl 10, 10), ' n/a');
      end;
      inc(Total, HMem);
    end;

    {Add the free memory to the total}
    inc(Total, FMem);

ExitPoint:
    if ShowFree or ShowSummary then
      PreSpace := 0
    else
      PreSpace := 5;
    if Verbose then
      inc(PreSpace, VerboseIndent);
    WriteLn('':PreSpace, CommaIze(LongInt(FMem) shl 10, 10), ' ', FreeName);
    if Total <> 0 then
      WriteLn('':PreSpace, CommaIze(LongInt(Total) shl 10, 10), ' ', TotalName);
  end;

  procedure ShowTheExtendedMem;
  var
    Total : LongInt;
    PreSpace : Byte;
  begin
    if GotXms or ShowFree then
      Exit;
    if ExtMemPossible then
      Total := ExtMemTotalPrim
    else
      Total := 0;
    if Total = 0 then
      Exit;

    WriteLn(^M^J'Raw Extended Memory');
    if ShowSummary then
      PreSpace := 0
    else
      PreSpace := 5;
    if Verbose then
      inc(PreSpace, VerboseIndent);
    WriteLn('':PreSpace, CommaIze(Total, 10), ' ', TotalName);
  end;

  procedure WriteCopyright;
    {-Write a copyright message}
  begin
    Write('MAPMEM ', Version, ', Copyright 1993 TurboPower Software'^M^J);
  end;

  procedure Initialize;
    {-Initialize various global variables}
  begin
    GotXms := False;
    TotalMem := 0;
    TopSeg := TopOfMemSeg;
  end;

  procedure GetOptions;
    {-Parse command line and set options}
  var
    Arg : String[127];

    procedure WriteHelp;
    begin
      WriteCopyright;
      WriteLn;
      WriteLn('MAPMEM produces a report showing what memory resident programs are installed,');
      WriteLn('how much memory each uses, and what interrupt vectors are taken over.');
      WriteLn;
      WriteLn('MAPMEM accepts the following command line syntax:');
      WriteLn;
      WriteLn('  MAPMEM [Options]');
      WriteLn;
      WriteLn('Options may be preceded by either / or -. Valid options are as follows:');
      WriteLn;
      WriteLn('     /C name  check whether TSR "name" is loaded.');
      WriteLn('     /E       report expanded (EMS) memory.');
      WriteLn('     /F       report free areas only.');
      WriteLn('     /H       do not use WATCH information for vectors.');
      WriteLn('     /L       do not report low memory blocks (<640K).');
      WriteLn('     /Q       write no screen output with /C option.');
      WriteLn('     /S       show summary of all memory areas.');
      WriteLn('     /U       report upper memory blocks if available.');
      WriteLn('     /V       verbose report.');
      WriteLn('     /X       report extended (XMS) memory.');
      WriteLn('     /?       write this help screen.');
      Halt(1);
    end;

    procedure UnknownOption;
    begin
      WriteCopyright;
      WriteLn('Unknown command line option: ', Arg);
      Halt(1);
    end;

    procedure BadOption;
    begin
      WriteCopyright;
      WriteLn('Invalid command line option: ', Arg);
      Halt(1);
    end;

    procedure GetArgs(S : String);
    var
      SPos : Word;
    begin
      SPos := 1;
      repeat
        Arg := NextArg(S, SPos);
        if Arg = '' then
          Exit;
        if Arg = '?' then
          WriteHelp
        else
          case Arg[1] of
            '-', '/' :
              case Length(Arg) of
                1 : BadOption;
                2 : case Upcase(Arg[2]) of
                      '?' : WriteHelp;
                      'C' : begin
                              CheckTSR := not CheckTSR;
                              if CheckTSR then begin
                                TSRName := StUpcase(NextArg(S, SPos));
                                if TSRName = '' then begin
                                  WriteCopyright;
                                  WriteLn('TSR name to check for is missing');
                                  Halt(1);
                                end;
                              end;
                            end;
                      'E' : ShowEmsMem := not ShowEmsMem;
                      'F' : ShowFree := not ShowFree;
                      'H' : UseWatch := not UseWatch;
                      'L' : UseLoMem := not UseLoMem;
                      'Q' : Quiet := not Quiet;
                      'S' : ShowSummary := not ShowSummary;
                      'U' : UseHiMem := not UseHiMem;
                      'V' : Verbose := not Verbose;
                      'X' : ShowExtMem := not ShowExtMem;
                    else
                      BadOption;
                    end;
              else
                UnknownOption;
              end;
          else
            UnknownOption;
          end;
      until False;
    end;

  begin
    TsrName := '';

    {Get arguments from the command line and the environment}
    GetArgs(StringPtr(Ptr(PrefixSeg, $80))^);
    GetArgs(GetEnv('MAPMEM'));

    {Account for related options}
    if ShowFree then
      ShowSummary := False;
    if not UseLoMem then
      UseHiMem := True;
    if ShowFree or ShowSummary then begin
      UseLoMem := True;
      UseHiMem := True;
      ShowEmsMem := True;
      ShowExtMem := True;
      Verbose := False;
    end;
    if not CheckTSR then
      Quiet := False;

    {Initialize for high memory access}
    HiMemSeg := FindHiMemStart;
    if HiMemSeg = 0 then
      UseHiMem := False;

    {Don't report any vectors normally taken over by SYSTEM}
    SwapVectors;

    {ExitProc will undo swap and restore high memory access}
    SaveExit := ExitProc;
    ExitProc := @SafeExit;

    {Find WATCH in memory if requested}
    if UseWatch then begin
      WatchPsp := WatchPspSeg;
      if WatchPsp = 0 then
        UseWatch := False;
    end;

    if not Quiet then
      WriteCopyright;
  end;

begin
  {$IFDEF MeasureStack}
  FillChar(Mem[SSeg:0], SPtr-16, $AA);
  {$ENDIF}

  Initialize;
  GetOptions;
  if CheckTSR then
    FindTSR
  else begin
    WriteLn;
    ShowConventionalMem;
    if ShowEmsMem then
      ShowTheEmsMem;
    if ShowExtMem then begin
      ShowTheXmsMem;
      ShowTheExtendedMem;
    end;
  end;

  {$IFDEF MeasureStack}
  I := 0;
  while I < SPtr-16 do
    if Mem[SSeg:i] <> $AA then begin
      writeln('Unused stack ', i, ' bytes');
      I := SPtr;
    end else
      inc(I);
  {$ENDIF}
end.